perm filename X.F4[NEW,LCS] blob
sn#701965 filedate 1983-02-03 generic text, type T, neo UTF8
C*** 4/82 ******** SUBROUTINE JUSTFY, FUNCTION OTHSID *************
SUBROUTINE JUSTFY(JLP,R,IR,NO,NP,RN,RSTFAC,R2,R4,R5,R6,R8,R9)
COPYRIGHT 1982 BY LELAND SMITH
COMMON /JSTFY/ROV,PRCNT,RJSZ/KJY/ KY,JY
DIMENSION IR(2,250),R(2,250),RN(1),NO(1),NP(1),RSTFAC(0/1)
DATA RBX/6.0/,RBZ/8.0/,SPFAC/0.20/
DO 11 KN=0,JLP
RSPC=0
R8=KN
N=0
DO 2 K=1,KY
L=NP(K)
RL=RN(L)
C RL=WDCNT-2
RA=RN(L+1)
C RA=CODE NUM.
RB=RN(L+3)
C RB=POSITION(P3)
IF(RN(L+2).EQ.R8)GO TO 77
C THIS STAFF?
IF(RA.NE.4)GO TO 2
C SKIPS HOMED NOTES (IN CHORDS)
77 IF(RA.LT.3)GO TO 20
IF(RA.EQ.4)GO TO 444
IF(RA.EQ.3)GO TO 333
C LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
C*** CAN'T WORK YET ***** IF(RA.LT.16)GO TO 2
IF(RA.LT.17)GO TO 2
GO TO 10
333 IF(RL.LT.3)GO TO 10
C <3 MEANS NOTHING IN P5
IF(RN(L+5).GT.4)GO TO 2
C NOT A REAL CLEF IF >4 (0=TREB, 1=BASS, 2=ALT, 3=TEN, 4=PERC.)
GO TO 10
444 IF(RL.GT.3.OR.RN(L+4).LT.0)GO TO 2
C IF P4.LT.0 THEN IT'S AN INVISIBLE BAR.
CC FOR REPEAT BAR WDCNT IS 3 -- 10/77 444 IF(RL.GT.2)GO TO 2
C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
GO TO 10
20 IF(RA.NE.2)GO TO 113
C ASSUMES WD CNT. IS GREAT ENOUGH!?!?!?!?
IF(RN(L+6))GO TO 2
IF(RN(L+7))GO TO 2
C SKIP INVIS. RESTS AND RESTS WITH NEG. RHYTH. (PUT THIS IN OTHER JUST. PROGS.)
GO TO 10
113 IF(RL.LT.7)GO TO 10
C NOW NOTES. SKIP IF NEG. VALUE IN P9 (IT'S A SUPPLEMENTAL NOTE.)
IF(RN(L+9).LT.0)GO TO 2
10 N=N+1
R(1,N)=RB
IR(2,N)=L
IF(N.EQ.250)GO TO 28
C ONLY TREATS 250 ITEMS AT A TIME.
2 CONTINUE
IF(N.EQ.0)GO TO 11
28 DO 23 K=1,N
23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
C SKIPS IF ONLY BAR LINES ON THIS STAFF
GO TO 11
24 RSZ=RSTFAC(KN)*PRCNT
CALL SORT2(R,N)
C JUMP IF LAST IS A BAR LINE.
K=0
JLDGR=0
JX=0
22 K=K+1
122 L=IR(2,K)
RA=RN(L+1)
C RA IS NOW CODE NUM.
RL=RN(L)
C RL=WDCNT-2
RB=0
RD=0
C RD WILL HOLD SPACE TO ADD TO PREV. ITEM, IF NEEDED.
RX=RN(L+5)
C RX=PARAM 5
RX6=RN(L+6)
RY=1
RW=AMOD(RN(L+4),100.)
RSP=SPFAC*RSTFAC(IFIX(RN(L+2)))
IF(RA.GT.1)GO TO 4
RZ=RN(L+7)
IF(LDGR.NE.JLDGR)JLDGR=0
C CHECK FOR PRESENCE OF LEDGER LINES WITH SUCCESSIVE NOTES
LDGR=0
JK=K
DO 32 JJ=JK+1,N+1
K=JJ
RB=R(1,JJ)-R(1,JJ-1)
IF(RB.GT.0.1)GO TO 320
C PUTS THEM AT EXACT SAME POINT IF CLOSER THAN .1
R(1,JJ)=R(1,JJ-1)
GO TO 32
320 IF(RB.GT.RSP)GO TO 35
32 CONTINUE
C FOUND HOW MANY MEMBERS TO CHORD.
35 RB=0
K=K-1
RQ=0
RC=ABS(RN(L+4))
IF(RC.LT.60)GO TO 637
IF(RC.LT.180)RY=.6
C FOUND A MINI-NOTE
637 RSDF=0
CC**** 4/82 CAN NEVER GET HERE!!! IF(RA.EQ.1)GO TO 437
C JUMP IF NOTE
CC RDF=-1
C NOW IT'S ANYTHING BUT A NOTE
CC GO TO 137
437 IF(RL.LT.8)GO TO 237
C JUMP IF THERE IS NOT P10 TO LOOK AT
RW=RN(L+10)
C PUT P10 INTO RW
GO TO 337
237 RW=0
337 IF(RDF.LT.0)GO TO 537
C JUMP IF PREVIOUS WAS NOT A NOTE
IF(RW.EQ.RDF)GO TO 137
C SKIP TO FAR END OF LOOP IF THINGS ARE ON DIFF. STAVES. (CLEFS?, ETC?)
RSDF=-1
537 RDF=RW
C SAVE STAFF INFO FOR NEXT TIME AROUND.
137 DO 37 JJ=JK,K
C******* IF(RD.NE.0)GO TO 38
C FINDS ONLY HIGH OR! LOW LED. LINE.
JR=IR(2,JJ)
C***************4/82****************
IF(RN(JR+1).NE.1.)GO TO 37
C SKIP ALL IF NOT A NOTE (PROBABLY A REST) IN SAME POS.
C **** TO BE ADDED ***** DOTTED REST IN SAME POS. ETC.
RW=AMOD(RN(JR+4),100.)
IF(RW.GT.12)GO TO 277
IF(RW.GE.2)GO TO 38
277 LDGR=-1
IF(RW.GT.11)LDGR=1
IF(JLDGR.EQ.LDGR)GO TO 36
JLDGR=LDGR
C LDGR IS FOR LEDGER LINES.
GO TO 38
36 IF(RD.GE.1.5)GO TO 38
RD=1.5
RQ=RD
38 IF(RB.GT.2)GO TO 222
C JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
CC IF(RN(JR).LT.5)GO TO 222
RZZ=RN(JR+7)
RE=RN(JR+5)
IF(RB.GE.2)GO TO 477
RC=1.5
IF(RZZ.LT.10)GO TO 378
IF(RZZ.GE.20)RC=3.
C 10=DOT, 20=DOUBLE DOT
GO TO 377
378 IF(RE.GE.20)GO TO 477
IF(AMOD(RZZ,10.).EQ.0)GO TO 477
377 RB=RC+EXTEN(RZZ)
C SPACE FOR DOT OR TAIL(IF STEM UP)
C *** STILL NEEDED ***** SEE IF VERT. POS. OF DOTTED NOTE IS CLOSE ENOUGH ****
477 IF(ABS(RN(JR+6)).EQ.10)RB=RB+2
C FOR CHORD TONES ON RIGHT OF STEM UP.
C LOOKS THROUGH ALL NOTES OF A CHORD.
222 RC=AMOD(RE,10.0)
IF(RC.EQ.0)GO TO 37
C JUMP IF NO ACCIS. NOW SEE IF THERE'S SPACE FOR ACCI.
C***************4/82****************
1222 IF(RN(JIR+1).NE.1)GO TO 425
C* RX=0
C* IF(RN(JR).GE.8)RX=RN(JR+10)
C* RXX=0
C* IF(RN(JIR).GE.8)RXX=RN(JIR+10)
C* RDF=0
C* IF(RX.NE.RXX)RDF=100.
C SAVE INFO ON NOTES ON DIFF. STAVES.
C* IF(RXX.EQ.1.OR.RX.EQ.2)RDF=-RDF
C**** THIS NEXT AREA PROBABLY NEEDS MORE WORK (2/78) ***********
C JIR IS POINTER TO PREVIOUS ITEM. SKIP IF NOT A NOTE.
KX=RC
C KX=ACCI ON CURRENT NOTE
RD=1
C ADD A LITTLE SPACE FOR ACCI. ANYHOW.
RX=RN(L+4)
RXX=ABS(RX)
C THIS NOTE
577 IF(RXX.LT.80)GO TO 677
C FIND MINIS, HARMONICS, ETC.
RXX=RXX-100
GO TO 577
677 IF(RX.LT.0)RXX=-RXX
RX=RXX
RDIF=RN(JIR+4)
RXX=ABS(RDIF)
777 IF(RXX.LT.80)GO TO 877
C FIND MINIS, HARMONICS, ETC.
RXX=RXX-100
GO TO 777
877 IF(RDIF)RXX=-RXX
RDIF=RX-RXX
C HEIGHT DIFF. JUMP OUT IF TOO CLOSE TOGETHER. AMOD IS FOR GRACE NOTES, ETC.
RX=3
JSTM=RN(JIR+5)/10.0
C JSTM=STEM DIRECTION OF PREVIOUS NOTE. 1=UP, 2=DOWN
IF(RDIF.GT.0)GO TO 427
C JUMP IF PREV NOTE IS BELOW. LIMITS: b OR NAT.=3, #=4
IF(JSTM.NE.2)GO TO 424
IF(AMOD(RN(JIR+7),10.0).GE.1)GO TO 425
C JUMP IF PREV. NOTE HAS STEM DOWN WITH TAIL. THEN WE NEED SPACE.
424 IF(KX.NE.2)RX=5
GO TO 428
427 IF(KX.EQ.2)RX=4
C PREV NOTE IS ABOVE. LIMITS: b OR NAT.=5, #=3
CC428 IF(ABS(RDIF).LT.RX)GO TO 425
CC IF(RDIF)GO TO 426
C JUMP IF THIS NOTE IS LOWER THAN PREV.
CC IF(JSTM.NE.1)GO TO 426
C NO BIG SPACE NEEDED IF PREV. NOTE HAS STEM DOWN AND IS BELOW.
C***************4/82****************
428 IF(ABS(RDIF).LT.RX)GO TO 425
IF(RDIF.LT.0)GO TO 1425
C JUMP IF THIS NOTE IS LOWER THAN PREV.
IF(JSTM.EQ.1)GO TO 425
C NO BIG SPACE NEEDED IF PREV. NOTE HAS STEM DOWN AND IS BELOW.
1425 IF(KIR.EQ.JIR)GO TO 426
C JUMP IF ONLY 1 ITEM IN PREVIOUS POSITION.
C NEXT FOR VARIOUS NOTES IN SAME POS. BEFORE NOTE WITH ACCI.
RW=RN(L+3)
C POS. OF THIS NOTE
DO 1426 MM=1,K
M=IR(2,MM)
C GET POINTER TO XRN ARRAY
IF(M.GT.1000)GO TO 1426
C THIS CHECKS FOR FLOATING POINT NUM. IN M
IF(RN(M+3).NE.RW)GO TO 1426
JIR=M
C NOW COMPARE WITH NEW NOTE
GO TO 1222
1426 CONTINUE
GO TO 426
CAN WE EVER GET HERE?
C***************4/82****************
425 RW=2.8
IF(IFIX(AMOD(RE,10.0)).EQ.4)RW=4.8
CATCHES DOUBLE FLAT (=4)
RD=RW*RY+EXTEN(RE)+OTHSID(RN,JR)
CGHB USE 2.8 FOR SIZE OF ACCIS (THEY'RE REALLY 3)425 RD=2*RY+EXTEN(RE)
426 IF(RQ.GT.RD)RD=RQ
RQ=RD
C FUNCT. EXTEN=AMOD(X,1.)*10.
37 CONTINUE
IF(RY.NE.1)RB=RB-.5*RJSZ
C MINI NOTES NEED LESS SPACE
250 IF(RSDF)GO TO 17
ACCX=0
CC RC=0
JN=JX+2
IF(JN.GE.N)GO TO 25
RW=R(1,JN-1)
DO 132 JJ=JN,N
IF(RW.NE.R(1,JJ))GO TO 25
KX=IR(2,JJ)
C GET POINTER
IF(RN(KX+1).NE.1)GO TO 25
C ONLY CHECK ON NOTES (THIS IS FOR CHRD NOTES WITH ACCIS)
CC RE=ABS(RN(KX+6))
CC IF(RE.GE.10)RC=-2.6
CC IF(RE.EQ.20)RC=-RC
RC=OTHSID(RN,KX)
RE=AMOD(RN(KX+5),10.0)
C FIND AN ACCI
IF(RE.GE.1)RC=RC+2
IF(IFIX(RE).EQ.4)RC=RC+2
C FOUND AN ACCI RE=4=DOUBLE FLAT
RC=AMOD(RE,1.0)*10.0+RC
C ADD ANY EXTENSION TO THE LEFT
IF(RC.GT.ACCX)ACCX=RC
CC RC=0
IF(ACCX.GT.RD)RD=ACCX
132 CONTINUE
GO TO 25
4 RDF=-1.
C RDF LATER SAYS PREVIOUS WAS NOT A NOTE
IF(RA.NE.2)GO TO 33
C NEXT FOR DOTTED RESTS - IN P6
IF(RL.LT.6.)GO TO 44
IF(RN(L+8).NE.0)GO TO 250
C P8=-1 MEANS WHOLE MEASURE REST (NEVER DOT, P6 CAN HAVE NUMB.)
C P8=POS MEANS WHOLE MEASURE REST WITH NUMBER.
44 IF(RL.GE.4)RB=RN(L+6)*1.5
C NOW GO BACK TO SEE IF THERE IS A NOTE IN SAME HORIZ. POS.
GO TO 250
33 IF(RA.NE.3)GO TO 29
RB=3
IF(RN(L+4).GT.80)RB=1.5
C CHECK ON SIZE NEEDED FOR CLEFS. >80 = MINICLEF
IF(JX.EQ.0)GO TO 17
IF(RN(JIR+1).EQ.4.)GO TO 17
C JUMP IF THIS IS FIRST ITEM OR PREVIOUS ITEM WAS BAR LINE
C RC = NEEDED SPACE FROM PREVIOUS ITEM (SETUP AT 17)
IF(R(1,K+1)-R(1,K).LT.RC)GO TO 17
C JUMP IF NOT REALLY ENOUGH SPACE FOR CLEF
JN=L+3
RD=RN(JN)-R(1,K-1)
C RD=SPACE FROM PREV. ITEM TO CLEF
IF(RD.GE.RC)GO TO 17
C ALREADY ENOUGH SPACE TO LEFT OF CLEF
RC=RN(JN)+RC-RD
C NOW NOT ENOUGH TO LEFT BUT PLENTY TO RIGHT - SO MOVE CLEF TO RIGHT
RN(JN)=RC
R(1,K)=RC
C RESET POSITION LOCATIONS
RB=0
GO TO 17
29 IF(RA.NE.4)GO TO 26
C BAR LINES
IF(RN(L+4).LT.0)GO TO 17
C SKIP IF INVISIBLE BAR LINE (FOR PAGE PROGRAM )
RB=-RJSZ/2
RD=.9
KX=RN(L+4)/1000.
IF(KX.LE.0.)GO TO 25
RD=RD+1.2
C ADD A LITTLE SPACE IN FRONT OF DBL BAR.
IF(KX.GT.1)GO TO 229
IF(RL.LT.3)GO TO 25
C JUMP IF THIN DBL BAR. OLD DBL BAR HAS 1 IN P5.
CCC IF(KX.EQ.1.OR.KX.EQ.3)RD=RD+RD
229 IF(KX.NE.2)RD=RD+RD
C 2=DOTS TO RT. 1 OR 4=DOTS TO LFT. 3=DOTS ON BOTH SIDES.
C REPT BAR WITH DOTS TO LEFT. ADD SPACE IN FRONT OF IT.
RB=-RB/RBX
IF(KX.EQ.4)KX=0
129 IF(KX.GE.2)RB=RBZ*RB
C IF DOTS TO RIGHT ADD MORE SPACE AFTER REPT BAR.
GO TO 25
26 IF(RA.NE.18)GO TO 30
C METER
RC=0
IF(RL.GE.7)RC=9
C FOR COMPOSITE METERS. NO CHECK FOR DBL DIGITS YET.
RB=-1
RD=1
IF(RX6.LE.9.AND.RX.LE.9)GO TO 31
C CHECKS FOR 2-DIGIT METERS
RD=2
RB=0
31 RB=RB+RC
GO TO 25
30 IF(RA.NE.17)GO TO 17
C30 IF(RA.NE.16)GO TO 34
C IF(RL.GE.8.0)GO TO 3 ***THIS NEXT CAN'T WORK YET ****
C P10 MUST =0 *** BECAUSE NO INFO IN P9 WITH SHORT GROUPS ***
C RC=R(1,N)
C P3 POSITION
C KY=L
C RX=0
C DO 134 KX=1,N
C L=IR(2,KX)
C IF(RN(L+1).NE.16.0)GO TO 134
C SKIP IF NEXT IS NOT WORD
C RW=0
C IF(RC.LE.RN(L+3))GO TO 134
C SKIP IF WORD IS TO RIGHT OF NEXT WORD
C334 RW=RW+RN(KY+9)
C UPDATE SPACE NEEDED (IN P9)
C IF(RN(KY+10).NE.16.0)GO TO 234
C JUMP OUT IS NEXT IS NOT WORD
C KY=KY+9
C IF(RN(KY).LE.7.0)GO TO 234
C JUMP OUT IF NEXT STARTS NEW GROUP OF CHARS.
C KY=KY+1
C GO TO 334
C234 RW=RN(L+3)+RW*RSZ
C NOW RW GIVES END POINT OF GROUP
C IF(RW.GT.RX)RX=RW
C RX IS POINT FOR COMPARISON (CAN OVERLAP)
C134 CONTINUE
C IF(RX.EQ.0.OR.RC-RX.GE.RSP)GO TO 3
C GO TO 3 IF ENOUGH SPACE ALREADY
C GO TO 25
C34 IF(RA.NE.17)GO TO 17
C KSIG
RX=ABS(RX)
IF(RX.GE.100)RX=RX-100
C +100 FOR NATURALS AS KEYSIG.
RB=2*(RX-1)-2
C SPACES FOR CORRECT NUM OF ACCIS. RX=NUM OF ACCIS.
RD=2
25 IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSZ
17 RC=(RB+RJSZ)*RSZ
C RJSZ=DEFAULT SIZE
JIR=L
C SAVE THE POINTER FOR ACCI. AND CLEF SECTION. CHECK AT 110
JX=K
C***************4/82****************
KIR=IR(2,JX)
C SAVE THIS POINTER (GETS WIPED OUT AT NEXT LINE) FOR STUFF AT 1425
C***************4/82****************
R(2,JX)=RC
3 IF(K.LT.N)GO TO 22
RA=R(1,1)
RB=R(2,1)
DO 13 KX=2,JX
RE=R(1,KX)
C POS. BEFORE SHIFTING
IF(ABS(RE-RA).GT.RSP)GO TO 14
CCC IF(ABS(RE-RA).GT..5)GO TO 14
IF(R(2,KX).GT.RB)GO TO 16
C SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
GO TO 13
C JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
14 RD=RA+RB-RE
IF(RD.LE.0)GO TO 16
C THERE'S ENOUGH ROOM
ROV=ROV+RD
140 R4=RE+RSPC-.001
R5=10000
R8=RD
R9=0
C GO EXPAND IT
IF(R(2,KX).EQ.0)GO TO 15
CALL MOVIT(RN,NO,R4,R5,R8,R9)
C???? IF(R2.LE.4)GO TO 15
C SKIP NEXT IF COMING FROM 'PAGE' OR 'JUST'
IF(R2.LE.7)GO TO 15
R5=R4
R4=RA+.001+RSPC
R8=R4
R9=R5+RD-.001
C FOR ITEMS ON OTHER LINES.
CALL MOVIT(RN,NO,R4,R5,R8,R9)
15 RSPC=RSPC+RD
C RSPC SAVES TOTAL SPACE ADDED
16 RB=R(2,KX)
13 RA=RE
11 CONTINUE
END
FUNCTION OTHSID(RN,J)
DIMENSION RN(1)
OTHSID=0
A=ABS(RN(J+6))
IF(A.GE.10)OTHSID=-2.6
C OTHSID=SPACE NEEDED (+ OR -) BECAUSE OF NOTE ON 'WRONG' SIDE OF STEM.
IF(A.GE.20)OTHSID=-OTHSID
END
C**** WORDS.F4 ****
COPYRIGHT 1982 BY LELAND SMITH
C WORDS, NAMEXT, TYPOUT, PACKX
SUBROUTINE WORDS
INTEGER PWDS
COMMON R2,JA,RC,J2,R3,R4,R5,R6,R7,X,IA,N
1,Z,J,KN,ISET,KNT,Q(26),JR /PTR/PWDS(1)
1 /LIMIT/LIMIT,ITEM,LL,IS,IX
C /SCX/ IS ALSO IN SCMSS, NOTBMS, RHYTH, BEAMS, NEWR(IN LOOP.FAI), SCAN.FAI
C **** WHEN JALPHA IS EXTENDED FIX LOOP AT 365 AND SUBR. NEWR(IN LOOP)
C **** AND SUBR. SCMSS, NOTBMS, RHYTH AND BEAMS
COMMON/SCX/ICOM,MINUS,IDOT,IEQ,LPRN,IRPRN,IPLUS,ISTAR,ICOLON,
1 ISEMI,IDBQT,IBLA,IDOL,IPRCNT,IANPR,IAT,INUM,LESS,IGT,IAPOS,
1 IQUES,IEXCLA,LBRK,RBRK,UPAR,DNAR,DBLAR,SLA,XX,ZZ,
1 J4,L,Y,K,RX,RZ,RA,J5 /XRN/RN(1) /ALF/INP(1) /IDEV/IDEV
C12/80 1 J4,L,Y,K,RX,RZ,RA,J5 /XRN/RN(1) /ALF/INP(72),ML
COMMON/SCN/KEL,KR,KU,KD,KSLA,NONO(30)
CC COMMON/SCN/LEL,LR,LU,LD,KSLA,LE,LC,LS,LF,LA,LI,LW
DIMENSION IAZ(26),JALPHA(30)
COMMON/A2Z/LA,LB,LC,LD,LE,LF,LG,LH,LI,LJ,LK,LEL,LM,
1 LN,LO,LP,LQ,LR,LS,LT,LU,LV,LW,LX,LY,LZ
EQUIVALENCE (ICOM,JALPHA),(INP2,INP(2)),(IAZ,LA),(LSQ,JALPHA(23))
DATA LEL/'L'/,LR/'R'/,LU/'U'/,LD/'D'/,LE/'E'/,KSLA/'/'/
1,LC/'C'/,LS/'S'/,LF/'F'/,LA/'A'/,LI/'I'/,LW/'W'/,XFONT/50./
DATA IAZ/'A','B','C','D','E','F','G','H','I','J','K','L','M',
1 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/,
1 IBKSL/"561004020100/
C IBKSL=\ BACKSLASH - PRINTS AN ORDINARY SLASH 3/82
DATA JALPHA/',','-','.','=','(',')','+','*',':',';'
1 ,'"',' ','$','%','&','@','#','<','>',1H','?','!'
1 ,"555004020100,"565004020100,"571004020100,"5004020100,
1 "135004020100,'/',"755004020100,"771004020100/
C 1ST 2 BIG NUMS ARE [, ], ↑, ↓, ↔, ... {, }
C 1/4 1/2 # b nat. --- 1/8
C FOR ENTERING TEXT: T, STF., POS., NT#., SIZE
IF(J2.GT.7)RETURN
C CATCH STAFF TYPO ERROR
KNT=-1
C COUNTER FOR SEPARATE TEXT ITEMS.
431 FORMAT(100A1)
IF(IDEV.NE.5)GO TO 131
231 IDEV=5
CALL TYPSTR('TYPE UP TO 100 CHARS--')
CALL TYPCRL
131 READ(IDEV,431,END=231)(INP(KN),KN=1,100)
C12/80 131 CALL TYPE
C12/80 531 DO 31 KN=72,1,-1
C NOW 100 CHARACTERS ACCPTED IN 'TYPE' MODE
531 DO 31 KN=100,1,-1
31 IF(INP(KN).NE.IBLA)GO TO 33
C KN=NUM OF CHARACTERS
C DON'T END WITH '*' IN 'LETTERS' INPUT!!!!!!!!
C , - . = ( ) + * : ; " BLANK (FONTS) ' --THIS IS ORDER PAST ALPHAB.
C ?[=1/8 NOTE, [=QTR NOTE, ]=HALF NOTE, ↑=#, ↓=b, ↔=NATURAL, 2 SLOTS STILL OPEN
C 50 &=NON-ITALICS(BDR), 51 @=ITALICS(BDI)
C 48 &&=BDB (BOLD-FACE) 49-1 @@ BOLD-FACE ITALICS (FUTURE ADDITIONS USE 49-N)
C 52 #=RETURN TO PRIMITVE FONT, 53 <=OPEN, 54 >=FILLED. ('=55)
C FRENCH ACCENTS=ACCUTE=64, GRAVE=65, CMFLX=66, UMLT=67, CIDLA=68, 69 =EIGHTH NOTE
C << >> $$ %% ##
33 L=1
RC=0
IF(INP(KN).NE.KSLA)GO TO 333
IF(INP(KN+1).NE.KSLA)GO TO 133
C TYPE // TO PRINT A SINGLE SLASH. (NO SPACE BETWEEN!) (BETTER TO USE \ )
333 KN=KN+1
INP(KN)=KSLA
C SO TRAILING BLANKS ARE DELETED.
133 LL=1
RZ=0
ISET=IS
IF(R3.LT.1000)GO TO 233
RZ=1
R3=R3-1000.
RC=R3
C ADD 1000 TO POSITION (R3+1000) FOR CENTERING AT POS. R3.
233 RA=R3
SET=RA
C IF SET = 0 THEN USE SETLET.
C RA= ADDS UP TOTAL SPACE NEEDED
RX=0
C FOR SETLET
C******** DASH
368 KA=INP(L)
IF(KA.NE.'?'.AND.KA.NE.'!')GO TO 117
C /??/ = PUT IN LONG DASH TO DIVIDE SYLLABLES. BUT MUST BE EDITED LATER!!!!!
C /!!/ = PUT IN SHORT DASH TO DIVIDE SYLLABLES. BUT MUST BE EDITED LATER!!!!!
IF(INP(L+1).NE.KA)GO TO 117
IA=L
L=L+2
217 IF(INP(L).EQ.'/')GO TO 317
L=L+1
IF(L.LT.KN)GO TO 217
317 ML=L
DO 417 N=IA,KN
C12/80 IF(ML.LT.72)ML=ML+1
IF(ML.LT.100)ML=ML+1
C MAKE ABOVE MORE 'ELEGANT'
INP(N)=INP(ML)
C GET RID OF /?? AND SLIDE DATA TO LEFT.
417 INP(ML)=IBLA
KN=KN-(L-IA)-1
L=IA
CC L=L+1
817 RN(IS)=8.
RN(IS+1)=4.
RN(IS+2)=R2
RN(IS+3)=RA-4.
RN(IS+4)=R4
RN(IS+5)=R4
RN(IS+6)=RA
RN(IS+7)=0
RN(IS+8)=0
RN(IS+9)=0
RN(IS+10)=1.
IF(KA.NE.'!')GO TO 917
C NOW SHORT DASHES
RN(IS+7)=1.
RN(IS+10)=2.
917 IS=IS+11
RZ=0
GO TO 1370
C******** DASH
117 RN(IS+1)=16
RN(IS+3)=RA
C NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
CC Y=39.6*RSTJ3
C RBL IS FOR CONTROL(NON-LETTERS, ETC.) CHARACTERS.
RN(IS+2)=R2
RN(IS+4)=R4
CALL NOZERO(R5)
RN(IS+5)=R5
IF(R5.GE.100)R5=R5-100
C >100 FOR TEXT IN ORCH SCORES TO GO IN ALL SEP. PARTS.
CKK KK=0
DO 364 J5=6,8
Z=0
CXX DO 363 J4=1,4
J4=1
361 IA=INP(L)
IF(IA.NE.KSLA)GO TO 365
C NEG. SPACE IS ENTERED IN P1 FOR EACH "FIRST" ITEM.
IF(INP(L+1).NE.KSLA)GO TO 433
C TYPE // TO PRINT A SINGLE SLASH. (NO SPACE BETWEEN!) (BETTER TO USE \ )
CKK KK=KK+1
L=L+1
GO TO 365
433 J3=J4
DO 367 KA=J5,8
X=99.
DO 366 K=J3,4
Z=Z+X
366 X=X*100.0
RN(IS+KA)=Z
J3=1
367 Z=0
L=L+1
C L=CHARACTER COUNTER
GO TO 369
365 DO 362 J=1,30
IF(IA.NE.JALPHA(J))GO TO 362
CC IF(J.NE.21)GO TO 360
C NOW '?'
CC IF(INP(L+1).NE.LSQ)GO TO 360
C NOW '?[' = EIGHTH NOTE N=69
CC L=L+1
CC J=34
360 N=35+J
C FOUND A SPECIAL CHARACTER.
IF(N.EQ.65)N=69
C NOW '}' = EIGHTH NOTE N=69
C*****************************************
3360 K=N
C*****************************************
IFNT=0
IF(N.LT.48)GO TO 39
IF(N.GT.54)GO TO 39
IF(IA.NE.INP(L+1))GO TO 39
C NEXT FOR DBL CHARS.
GO TO(1,2,3,300,7,4,5)N-47
CC GO TO(1,2,3,39,7,4,5)N-47
C FOR FRENCH ACCENTS
1 N=66
CIRCUMFLEX TYPE $$
GO TO 6
2 N=67
C UMLAUT TYPE %%
GO TO 6
3 N=48
C &&=BDH40 FONT BOLD-FACE
GO TO 6
300 N=49
C @@=BIH40 BOLD ITALICS
GO TO 6
4 N=64
C ACCUTE TYPE >>
GO TO 6
7 N=68
C CEDILLA TYPE ##
GO TO 6
5 N=65
C GRAVE TYPE <<
CC IF(N.NE.50)GO TO 39
CC IF(IA.NE.INP(L+1))GO TO 39
6 K=N
L=L+1
C TYPE && FOR BOLD-FACE (BDB). PUSH PTR (L) ALONG 1 MORE.
GO TO 39
362 CONTINUE
C*****************************************
IF(IA.NE.IBKSL)GO TO 38
N=63
C BACKSLASH WILL PRINT ORDINARY SLASH
GO TO 3360
C*****************************************
38 N=10-(LA-INP(L))/536870912
C MAGIC NUMBER TO FIND LETTERS
IF(N.LT.10)N=N+7
K=N
IF(KFNT)IFNT=0
IF(N.LT.40)GO TO 39
N=N+28
KFNT=-1
C TO INITIALIZE AUTOMATIC LOWER CASE SYSTEM.
K=N-60
C K IS ACTUAL LETTER NUMB. (a=10, ETC.)
IFNT=-1
C LOWER CASE LETTERS ARE 60 .GT. UPPER. A=10, a=70, b=71, etc.
39 L=L+1
C BLANK=47 =99 WHEN NO MORE CHARS TO COME.
C*********** NEW 12/79 ****** ALSO CHANGE 363 LOOP******************
IF(N.LT.48.OR.N.GT.52)GO TO 392
C SAVE THE FONT CODE
XFONT=N
GO TO 391
392 IF(J4.NE.1)GO TO 391
C SKIP IF FONT CODE OR NOT 1ST CHAR. OF GROUP
IF(RX.NE.0)GO TO 391
IF(RZ.NE.0)GO TO 391
C PUTS FONT CODE AT FIRST OF EACH CHAR. GROUP.
J4=J4+1
Z=XFONT*1000000.
C*******************************************************
391 IF(N.LT.64.OR.N.GT.68)CALL SPACER(K,IFNT,RX,3.32)
CC 63=SLASH 391 IF(N.LT.63.OR.N.GT.68)CALL SPACER(K,IFNT,RX,3.32)
C NUM↑↑=19.7/5.96 FOR BASIC SPACE PER LETTER.
C GET SPACE FOR THIS LETTER. IGNORE ACCENTS (63-68)
X=N
IF(J4.EQ.2)X=X*10000.
IF(J4.EQ.3)X=X*100.
IF(J4.EQ.1)X=X*1000000.
363 Z=Z+X
J4=J4+1
IF(J4.LE.4)GO TO 361
364 RN(IS+J5)=Z
369 RN(IS+9)=RX
RN(IS+10)=RZ
IF(RZ.EQ.0)KNT=KNT+1
IF(RC.NE.0)RN(IS+10)=RC
RC=0
C FOR CONTINUATION
RA=RA+RX*R5
IF(IA.EQ.KSLA)RA=RA+5
C SPACES GROUPS DIVIDED BY SLASHES
RX=0
C*** IF(RZ.NE.0)GO TO 370
C SKIP IF P10=1, REQUIRED FOR CONTINUATION OF TEXT.
C*** IF(IBLANK(IS,7))RZ=-2
C IF LAST CHAR IN P7 IS BLANK RESET WDCNT, GET RID OF P8 AND P9
C*** IF(IBLANK(IS,6))RZ=-3
C ↑↑↑↑ LAST CHAR IN P6=BLNK ZAPS P7 IF NOT NEEDED. RZ=- CHANGES WORDCNT
C***370 RN(IS)=7+RZ
C NOW WILL PUT SIZE INTO P9 ALWAYS. (FOR CODE 4 DASH CENTERING FEATURE.)
370 IF(RZ.LT.0)RZ=0
C***370 RN(IS)=7+RZ
RN(IS)=7+RZ
IS=IS+10+RZ
RZ=1.
IF(IA.EQ.KSLA)RZ=0
1370 LL=LL+1
PWDS(ITEM+LL)=IS
C PUT IT IN THE PNTR ARRAY
IF(L.LT.KN)GO TO 368
C WAS ↑↑↑↑↑↑↑ .LE. 5/22/76
IX=ITEM+LL-1
C IX IS FOR DASHES
IF(SET.EQ.0)CALL SETLET
C GOES TO SETLET AUTOMATICALLY IF P3 = 0.
CCC IF(KNT.GT.0)CALL SETLET
C GOES TO SETLET AUTOMATICALLY IF MORE THAN ONE SLASH FOUND.
IF(KFNT)IFNT=0
KFNT=0
INP(1)=0
C SO IT WON'T FIND A COMMAND IN THE MAIN PROG.
END
C PACKS 4 CHARS/WD, 3 WDS/ITEM.
CC SUBROUTINE NAMEXT(JA,NAME,IEXT)
SUBROUTINE DUMMY
COMMON /MKX/MKX(7),PRNL
DIMENSION JA(1),A(5),FM(7)
DATA A/'A1','A2','A3','A4','A5'/,FM(1)/'('/
EQUIVALENCE (A5,A(5)),(FM2,FM(2)),(FM3,FM(3)),(FM4,FM(4)),
1 (FM5,FM(5)),(FM6,FM(6)),(FM7,FM(7)),(A3,A(3))
DO 9 K=2,7
9 FM(K)=' '
ID=0
IA=0
NAME=' '
DO 1 K=20,1,-1
IF(JA(K).EQ.' ')GO TO 1
5 DO 2 L=K-1,1,-1
J=JA(L)
IF(J.NE.' ')GO TO 3
IA=L
GO TO 4
3 IF(J.NE.'.')GO TO 2
ID=L
K=L
C '.' ASSUMES THERE IS AN EXTENSION
GO TO 5
2 CONTINUE
GO TO 4
1 CONTINUE
C ALL BLANK IF WE GET HERE
RETURN
4 IF(IA.NE.0)GO TO 6
IF(JA(1).EQ.-1)RETURN
C ↑↑↑ FOR 'RS', 'SA', 'G', ETC. WITH NO NAME FOLLOWING.
IF(ID.NE.0)GO TO 7
C NOW ONLY A NAME IS ON THIS LINE
FM2=A5
FM3=PRNL
C GET LEFT PARENTHESIS
REREAD FM,NAME
GO TO 10
7 FM3=',A1,'
FM2=A(ID-1)
FM4=A3
FM5=PRNL
C FOUND NAME AND EXTENSION
REREAD FM, NAME,K,IEXT
GO TO 11
6 IF(IA.GT.5)RETURN
C .GT.5 = TOO MUCH IN FRONT OF NAME!!
FM2=A(IA)
FM3=','
IF(ID.NE.0)GO TO 8
FM4=A5
FM5=PRNL
C FOUND 'WORD', NAME WORD= SA, RS, GM, ETC.
REREAD FM,K,NAME
GO TO 10
8 FM4=A(ID-IA-1)
FM5=',A1,'
FM6=A3
FM7=PRNL
REREAD FM,K,NAME,K,IEXT
11 CALL LO2UP(IEXT)
10 CALL LO2UP(NAME)
END
SUBROUTINE TYPOUT
COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,
1 JX,ISM,IQ,VX(50),IMP,K,KN,M,MD,IBLA /ALF/INP(72) /IDEV/IDEV
IF(IDEV.NE.5)RETURN
DO 1 KK=72,1,-1
1 IF(INP(KK).NE.IBLA)GO TO 2
2 CALL TYPINT(MODE)
CALL TYPCHR(' ',3)
DO 3 KKK=1,KK
3 CALL TYPCHR(INP(KKK),1)
CALL TYPCRLF
END
SUBROUTINE PACKX(NAM,KNM)
DIMENSION KNM(5)
DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
1 , MM/"774000000000/
NAM=0
DO 12 K=5,1,-1
NAM=NAM .OR. (KNM(K) .AND. MM)
IF (K.EQ.1)RETURN
17 IF (NAM.GE.0)GO TO 13
NAM = (( NAM .AND. LL)/KK) .OR. JJ
GO TO 12
13 NAM = NAM / KK
12 CONTINUE
RETURN
END
SUBROUTINE NAMEXT(I,NAME,IEXT)
C FINDS NAME.EXT IN A1 STRING
DIMENSION I(1)
IF(I(1).NE.-1)GO TO 9
C FIRST PASS UP 'G', 'GM', 'RS', ETC. (=-1)
DO 1 K=1,72
1 IF(I(K).EQ.' ')GO TO 2
C NOW PASS BLANKS
2 J=72
DO 3 J=K+1,72
3 IF(I(J).NE.' ')GO TO 4
C NOW FOUND START OF WORD (UNLESS ALL BLANKS)
4 IF(J.NE.72)GO TO 5
NAME=' '
RETURN
9 J=1
5 DO 6 K=J,72
IF(I(K).EQ.' ')GO TO 7
C JUMP IF NAME ONLY
6 IF(I(K).EQ.'.')GO TO 8
7 CALL PACKX(NAME,I(J))
RETURN
8 CALL RLOOP(I(61),I(J),K-J)
CALL PACKX(NAME,I(61))
CALL PACKX(IEXT,I(K+1))
END
C**** RESTS.F4 *****
COPYRIGHT 1982 BY LELAND SMITH
C****** SUBRS TAIL, FERMTA, REST, BREP, (SORT2), PNUM, LO2UP
SUBROUTINE TAIL
COMMON/ALF/INP(49),RMINI,RINV,RA,RX,RJX,NONO(19)
COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS
1 /JCHAR/IXX,ISEMI,IBLA,IG
DIMENSION ITAIL(16)
DATA ITAIL/16,100090007,110012,120016,200120016,120019,100026,
1 80030,20036, 40, 33, 30031, 50029,80025,100022,120016/
C--MISC. DATA FOR OTHER PLACES. ↓↓↓↓↓↓↓
DATA IXX/'X'/,IG/'G'/,ISEMI/';'/,IBLA/' '/
CALL CENTER(RJY)
Q=-1.
IF(RA)Q=1.
IF(IPLT)GO TO 2
ITAIL(1)=10
1 CALL JDRAW(ITAIL,RJX,RJY,RMINI,1.,Q)
RETURN
2 P=Q
IF(RMINI.NE.RSTJ2)P=P*RMINI/RSTJ2
CC IF(RMINI.NE.RSTJ2)P=P*.6
ITAIL(1)=16
CALL FILLMS(12,ITAIL(5),RJX,RJY,ABS(P),P)
C RA=-,STEM UP; RA=+, STEM DOWN.
GO TO 1
END
SUBROUTINE REST
COMMON /STF/RSTFAC(8),RSTJ2/PLTR/IPLT,RHT,DIS
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
EQUIVALENCE(J5,JQ(3)),(R3,RJQ(1)),(R4,RJQ(2)),(R7,RJQ(5))
1,(R6,RJQ(4)),(R8,RJQ(6)),(R5,RJQ(3)),(R10,RJQ(8)),(J4,JQ(2))
1,(R9,RJQ(7)),(J8,JQ(6))
DIMENSION LRST(3),IRST(47),MR(2),MF(2)
DATA IRST/9,100000033,160033,160030, 30,32 ,160032 ,160031,
1 31, 23,100000051,100038,32,110017,200050044, 32 ,50026,
1 100038,50044,100110017,70018,50017,50015,60011, 10016,
1 18, 20,10022,30023, 50023, 70022,110017,
1 15,100030033, 40032, 80032,120035,150039,70014,200010037,
1 30039, 50039, 70037, 70035, 50033, 30033,10035/
1,LRST/1,10,33/,MR/18,8/,MF/15,40/
C LRST = BEGINNING OF EACH REST, MR=FILLER WDCNT, MF=FILL START.
L=J5
IF(L.GT.1)L=1
IF(L)L=-1
C L>3 WHEN SEVERAL TAILS ON REST
R10=RSTJ2
IF(IABS(J4).LT.80)GO TO 2
C NEXT FOR MINI-RESTS
RSTJ2=RSTJ2*.7
J4=0
R4=R4+2.
2 CALL CENTER(CENTR)
RA=1.
RB=R3
IF(R8.GT.-3)GO TO 10
CALL BREP
GO TO 1
10 IF(J5.GT.-3)GO TO 9
C -3 IN P5 = DOUBLE WHOLE REST. R8=-4 OR -5 =REPEAT BAR SIGN.
CQQC -3 IN P5 = DOUBLE WHOLE REST. -4=REPEAT BAR SIGN.
CQQ IF(J5.NE.-4)GO TO 10
CQQ CALL BREP
CQQ GO TO 1
CQQ10 J5=-5
J5=-5
RA=2.
RB=RB-8*RSTJ2
C TO CENTER THE DOUBLE WHOLE REST.
9 IF(J5.GE.0)GO TO 5
IF(J5.LT.-2)GO TO 12
C JUMP FOR DOUBLE WHOLE-REST
B=R8
C=R6
D=R7
X=R4
K=-J5
J8=0
R8=0
R6=0
R7=0
JA=3
J5=8
CC A=4.12
IF(K.EQ.2)R4=R4+1.05
CC R4=R4+A
CEN=CENTR
CALL CLEFS
C GO DRAW HALF OR WHOLE REST, THEN GET BACK PARAMS.
CENTR=CEN
J5=-K
R8=B
R4=X
R6=C
R7=D
GO TO 11
12 CENTR=CENTR+9.4*R10
C CENTERS WHOLE REST
5 CALL JDRAW(IRST(LRST(L+2)),RB,CENTR,RSTJ2,RA,1.)
IF(J5.GT.-3)GO TO 4
J5=J5+1
CENTR=CENTR-3.133*R10
GO TO 5
4 IF(J5.GE.0)GO TO 6
CHECK FOR NEED OF LEDGER LINES (1/2 AND WHOLE RESTS)(NOT FOR DBLS).
11 RA=5
RB=-5
CENTR=CENTR+29*RSTJ2
IF(J5.EQ.-1)GO TO 8
CENTR=CENTR+14*RSTJ2
CC CENTR=CENTR+5*RSTJ2
RA=3
RB=-7
C THESE FOR WHOLE RESTS. ABOVE FOR 1/2.
8 IF(R4.GE.RA)GO TO 7
IF(R4.GT.RB)GO TO 6
7 IF(R9.NE.0)GO TO 6
C P9≠0 SUPRESSES LEDGER LINE.
RA=R3-7*RSTJ2
RB=R3+25*RSTJ2
CC RB=R3+22*RSTJ2
CALL LINX(RA,CENTR,RB,CENTR)
6 IF(IPLT.GE.0)GO TO 1
IF(J5)GO TO 1
L=L+1
CALL FILLMS(MR(L),IRST(MF(L)),R3,CENTR,1.,1.)
C WHY GO THROUGH NOTWRT??
1 IF(R8.EQ.0)RETURN
C TO PUT NUM OVER REST - MULTIPLE BARS.(R8=-1 =NO NUM. OVER WHOLE RST)
R4=R4+10.6
C HEIGHT ??
IF(IPLT)GO TO 3
R6=5.96*R6
C USE PARAM 6 TO CHANGE SIZE OF CENTERING AID LINE.
IF(R6.EQ.0)R6=55.
CALL LINX(R3-R6,CENTR,R3+R6+16.0*RSTJ2,CENTR)
C HORIZ. LINE FOR CENTERING ON DPY ONLY. WILL NOT PRINT!
C NEXT IS J3
3 JQ(1)=ROFF(R3+8.*RSTJ2)
R5=R8
R6=1.5
C NUMBER SIZE
R8=0
C ↑↑↑↑↑ ALL THIS BECAUSE OF PARAM NUMS IN MAKNUM AND NOTWRT
R7=0
C FOR BDR40 FONT
IF(R5.GE.1.)CALL MAKNUM(R5)
J5=0
R7=0
C ↑↑↑↑↑ NEEDED??
END
C READS DATA
C FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
SUBROUTINE BREP
CX DIMENSION IREP(35)
C COMMON R2,JA,CENTR,J2,R3,RJQ(39) /STF/RSTFAC(8),RSTJ2
COMMON R2,JA,C,J,R3,R4,R5,R6,R7,RJQ(16),RA,J5
CX DATA IREP/35,100000015,280043,290043, 10015, 20015, 300043,310043
CX 1,30015, 40015, 320043,100020037, 30038, 40038, 50037
CX 1,50036, 40035, 30035, 20036, 20037, 50037, 20036, 40036
CX 1,100270022,280021,290021,300022,300023,290024,280024,270023
CX 1,270022, 300022, 270023, 290023/
C CALL CENTER(R)
C CALL JDRAW(IREP,R3,R,RSTJ2,1.,1.)
RA=R6
JA=3
J5=39
R6=3.3333333
R7=R6
CALL CLEFS
R6=RA
END
SUBROUTINE FERMTA
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS
1 /ALF/INP(49),RMINI,RINV,NO(22)
EQUIVALENCE(J5,JQ(3)),(R4,RJQ(2)),(R7,RJQ(5)),(ISTEM,JQ(20))
1,(R6,RJQ(4)),(R8,RJQ(6)),(R3,RJQ(1))
1,(R9,RJQ(7)),(RA,JQ(4)),(RX4,JQ(19))
DIMENSION JFERM(46)
DATA JFERM/24,310020003,10010010,20015,60017,120017,160015,
1 190010,200003,170010,150012,110014,70014,30012,10010,
1 10020003,100070007,80008,100008,110007,110006,100005,80005
1 ,70006,70007,20,100081006, 80012, 90012, 91006, 110030002,
1 30008,70002,130008,170002, 200005, 200170002,141001,100005,
1 130008,170002, 100070002, 41001, 5, 30008, 70002/
IF(J5.EQ.25)GO TO 9
IF(J5.EQ.26)GO TO 6
IF(J5.LT.21)GO TO 6
C NEXT FOR MUSICA FICTA, 1,2,3=FLT,#,NAT. (IN CLEFB.DMD)
C J5=22=1(FLT), =23=#, =24=NAT.***** 27,28,29 STILL OPEN ********
7 J5=J5-12
R7=0
R6=.42
C R6 (SIZE) COULD BE CHANGED ****
R4=RX4+0.8
CC 2/81 R4=RX4+1.8
IF(ISTEM.EQ.1)R4=R4+5
IF(R4.LT.10.5)R4=10.5
CC 2/81 IF(R4.LT.11)R4=11
R3=R3+15*RSTJ2
8 R8=0
R9=0
CALL CLEFS
RETURN
C NEXT FOR HEAVY WEDGE ACCENT
9 J5=44
C TO BE FOUND IN 'CLEF4.DMD'
RA=1.8
IF(ISTEM.EQ.1)R7=-1
C 2= STEM DOWN
IF(R7)RA=-7.7
R4=RX4+RA
R6=1
GO TO 8
6 IF(RINV.LT.17)GO TO 1
JFERM(30)=16
JFERM(36)=210005
IF(RINV.NE.17)GO TO 2
JFERM(30)=91006
J=26
GO TO 4
2 JFERM(30)=16
C FOR INVERTED MORDANT
J=30
4 RINV=1.
GO TO 3
1 J=1
3 CALL JDRAW(JFERM(J),R3,CENTR,RMINI,1.,RINV)
IF(IPLT.GE.0)RETURN
IF(J.EQ.1)GO TO 5
J=36
JFERM(36)=10
5 RA=RSTJ2
RSTJ2=1
CALL FILLMS(JFERM(J),JFERM(J+1),R3,CENTR,RMINI,RMINI*RINV)
RSTJ2=RA
C BECAUSE FILLMS MULTS RMINI*RSTJ2.
END
SUBROUTINE PNUM
INTEGER XAC
COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,RJQ(16),J3,J4,J5,J6,J7,
1 J10J,IPUNC,DONT,RXX,RX,JQ(10) /STF/RSTFAC(0/7),RSTJ2
1 /PLTR/IPLT,RHT,DIS,XDIS
DIMENSION NUMQ(44),RNUMS(341)
COMMON/DAT/RACNT(69),RDOT(17),XAC(7),RNOTE(22),RACCI(22),NACCI(3)
C ACCENTS BEGIN > ∧ DNBOW UPBOW 1ST NUM=END PT OF EACH ITEM
DATA RACNT/4.,1000.006,17.001,0.104, 8.,1003.0, 7.014, 11.0
1,13. ,1000. ,0.010,14.01,14. ,17. ,1001.018,7. ,13.018,31.,
1 1003.001, 4.003, 6.004, 8.004,10.003,11.001, 11.101,
1 10.103,8.104,6.104,4.103, 3.101, 3.001,
1 36.0,1000.0,14.0,1007.007,7.107, 47.0,1012.01,11.006,9.003
1, 7.001, 5.0, 9.002, 13.006, 15.01, 10.004, 13.009, 56.0,
1 1002.008,3.003, 5.001, 8.0, 10.0, 13.001, 15.003, 16.008,
1 69.,1106.104, 0.002, 6.104, 12.002, 18.104, 24.002, 24.003,
1 18.103, 12.003, 6.103, 0.003, 106.103/
C RNOTE 1-7=DPY WHITE NOTE, 8-12=DIAMOND, 13-16=X, 17-22=DPY BLACK NOTE
C DIAMOND AND X SHIFTED TO RIGHT BECAUSE USED 3 TIMES TO THICKEN.
C ORDER=WHITE, X, DIAMOND, BLACK
DATA RNOTE/ 1000., 5.007, 11.007, 16., 11.107, 5.107, 0.0,
1 1001.0, 8.007, 15.0, 8.107, 1., 1001.107, 15.007,
1 1015.107,1.007, 1000.003,4.107,6.007,9.107,11.007,14.103/
DATA RDOT/1000.101, .102, 1.103, 2.103, 3.102, 3.101, 2., 1.,
1 .101, 2.103, 2., .102, 3.102, 1., 1.103, 3.101, .102/
1 ,XAC/9,14,18,32,37,48,57/
C ALL DATA NUMS OVER 90 GIVE INVISIBLE VECTORS
DATA RACCI/6.0,1115.003, 110.007, 106.001,
1 115.109, 115.021, 15.0, 1104.104, 118.108,
1 1108.113, 108.016, 1104.008, 118.004,
1 1114.014, 114.115, 22.0,1106.117, 106.007, 114.004
1, 1114.018, 114.107, 106.104/
1 ,NACCI/1,7,16/
DATA
1 NUMQ/1,11,15,23,33,38,47,57,62,79, 89,95,108,117,125,132,138
1,150,157,164,171,177,181,187,1,192,200,212,221,234,239,246
1,250,256,261,266, 271,282,285,293,298,314,330,335/
DATA (RNUMS(K),K=1,131)/10.0,1003.107, 6.102, 6.01, 3.015,
1 104.015, 107.01,107.102, 104.107, 3.107,
1 14.0, 1105.011, 101.015, 101.107, 22.0,
1 1106.011, 102.015, 3.015, 7.011, 7.005, 107.107, 7.107, 32.0,
1 1107.015, 7.015, 101.007, 3.007, 7.003, 7.102, 3.107, 103.107,
1 107.103, 37.0, 1007.102, 107.102, 2.015, 2.107, 46.0, 1107.107,
1 4.103, 7.0, 7.004, 2.006, 107.004, 107.015, 7.015, 56.0,
1 1004.015, 107.0, 107.103, 103.107, 4.107, 7.103, 7.0, 3.003,
1 104.003, 61.0, 1107.011, 107.015, 7.015, 107.107, 78.0, 1003.004,
1 7.0, 7.103, 4.107, 104.107, 107.103, 107.0, 103.004, 3.004,
1 6.008, 6.012, 2.015, 102.015, 106.012, 106.008, 103.004,
1 88.0, 1104.107, 7.008, 7.011, 4.015, 104.015, 107.011, 107.008,
1 103.005, 4.005, 94.0, 1106.107, 0.015,6.107,1004.101,104.101,
1 107.0, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 1106.004,
1 2.004, 6.001, 6.104, 3.107, 106.107, 116.0, 1006.104, 3.107,
1 103.107, 106.104, 106.011, 103.015, 3.015, 6.011, 124.0,
1 1106.107, 106.015, 3.015, 6.011, 6.103, 3.107, 106.107,
1 131.0, 1006.107, 106.107, 106.015, 6.015, 1003.005, 106.005/
C THE NEXT IS FOR 'F' TO 'P'
C 1 NUM NOT NEEDED IN 'G' ALSO IN RNOTE (1/2 NOTE).
DATA (RNUMS(K),K=132,199)/
1 137.0, 1106.107, 106.015, 6.015, 1003.005, 106.005, 149.0,
1 1001.102, 6.102, 6.104, 6.104, 3.107, 103.107, 106.104,
1 106.011, 103.015, 3.015, 6.011, 156.0, 1106.107, 106.015,
1 1006.015, 6.107, 1006.005, 106.005, 163.0, 1106.107, 0.107,
1 1103.107, 103.015, 1106.015, 0.015,
1 170.0, 1110.102, 110.105, 108.107, 103.107, 101.105, 101.015,
1 176.0, 1106.107, 106.015, 1006.015, 106.005, 6.107, 180.0,
1 1006.107, 106.107, 106.015, 186.0, 1106.107, 106.015, 1.004,
1 8.015, 8.107, 191.0, 1106.107, 106.015, 6.107, 6.015, 199.0
1, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 106.004/
C 'Q' TO ')'
DATA(RNUMS(K),K=200,341)/
1 211.0, 1003.107, 6.102, 6.01, 3.015, 103.015, 106.01, 106.102,
1 103.107, 3.107, 1001.001, 7.108, 220.0, 1106.107, 106.015,
1 3.015, 6.012, 6.007, 3.004, 106.004, 6.107, 233.0, 1106.104,
1 103.107, 3.107, 6.104, 6.001, 3.004, 103.004, 106.007, 106.011,
1 103.015, 3.015, 6.01, 238.0, 1106.015, 7.015, 1000.015, 0.107,
1 245.0, 1106.015, 106.104, 103.107, 3.107, 6.104, 6.015, 249.0,
1 1106.015, 0.107, 6.015, 255.0, 1106.015, 103.107, 1.005, 5.107,
1 8.015, 260.0, 1106.015, 6.107, 1106.107, 6.015, 265.0, 1106.015,
1 0.003, 1106.107, 6.015, 270.0, 1106.015, 6.015, 106.107, 6.107,
1 281.0, 1105.102, 105.105,103.105,104.102,104.105,105.102,103.102,
1103.108, 106.112, 1106.112, 284., 1110.003, 2.003, 292., 1105.102,
1 105.105,104.102,104.105,103.102,103.105,105.102,297.0,1108.007,
1 4.007, 1108.0, 4.0, 313.0, 1102.015, 104.013, 106.010,
1 107.006,107.002,106.102,104.105,102.107, 104.104,105.102,106.002
1 ,106.006,105.01,104.012,102.015, 329.0,1106.015,104.013,
1 102.01 ,101.006,101.002,102.102,104.105,106.107, 104.104,103.102
1 ,102.002,102.006,103.01,104.012,106.015, 334.0,1110.003,
1 2.003, 1104.009, 104.103, 341.0,1110.004, 2.004, 1101.009,
1 107.101, 1101.101, 107.009/
C 3RD ITEM IN 19400 NOT NEEDED 12/73
C 1-10=NUMS 0-9, 11-36=ALPHA, 37-42=SIGNS
C = AT 297.0 WAS MOVED 2 TO RIGHT. 5/80
CALL CENTX
J10J=J5
CALL NOZERO(R6)
SIZ=R6*RSTJ2
JTH=0
IPUNC=0
IF(J10J.LT.44)GO TO 1
IPUNC=J10J
IF(J10J.EQ.44)J10J=38
IF(J10J.GE.45)J10J=36
IF(J5.NE.46)GO TO 451
RXX=4
CALL RJBX(-RXX)
RX=16
CENTR=CENTR+RX*SIZ
1 IF(IPLT.GE.0)GO TO 451
IF(J10J.EQ.37)GO TO 2
IF(J10J.EQ.39)GO TO 2
IF(J10J.NE.42)GO TO 451
2 JTH=-2
451 IX=NUMQ(J10J+1)
C IX=END # OF ITEM
C IX+1=1ST PART OF ITEM
CCCC IF(SIZ.LE.1.)CENTR=CENTR+(1.-SIZ)/.45
C ABOVE TO COMPENSATE FOR POOR VERTICAL POSITION OF FONTS (I THINK)
3 CALL RDRAW(IX+1,RNUMS(IX),RNUMS,SIZ,R3,CENTR+RSTJ2*3.,SIZ)
IF(JTH.EQ.0)GO TO 4
IF(J10J.GE.42)R3=R3+XDIS
CENTR=CENTR+XDIS
JTH=JTH+1
C THIS PLOTS TRIPLE THICKNESS FOR - = + /
GO TO 3
4 IF(IPUNC.EQ.0)RETURN
IF(IPUNC.NE.46)GO TO 351
CALL RJBX(SIZ*2.*RXX)
C FOR "
651 IPUNC=0
GO TO 451
351 RXX=11
C FOR : AND ;
CENTR=CENTR+RXX*SIZ
J10J=38
GO TO 651
END
SUBROUTINE LO2UP(J)
C CONVERTS ALL LOWER CASE TO UPPER CASE.
J=J.AND..NOT.((J/2).AND."201004020100)
END